Datos de observaciones actuales

ruta_productos <- "C:\\Users\\Usuario\\Downloads\\ARCHIVOS DE POSIT\\PRODUCTOS_2025.xlsx"
#"/cloud/project/PRODUCTOS_2025.xlsx"
excel_sheets(ruta_productos)
## [1] "Sheet 1"
Productos2025 <- as.data.frame(read_xlsx(ruta_productos, sheet ="Sheet 1"))
Productos2025$Semana <- format(Productos2025$Fecha, format ="%Y-%U")
Fecha2025 <- Productos2025$Fecha
Productos2025 <- Productos2025 %>% 
  group_by(Fecha = as.Date(Fecha)) %>% 
  summarize(Totales = sum(Totales), 
            .groups = "keep")
head(Productos2025)
## # A tibble: 6 × 2
## # Groups:   Fecha [6]
##   Fecha      Totales
##   <date>       <dbl>
## 1 2024-12-07   2926.
## 2 2025-01-03   2466.
## 3 2025-01-08   1672.
## 4 2025-01-09   7273.
## 5 2025-01-10  20880 
## 6 2025-01-11   8352
tail(Productos2025)
## # A tibble: 6 × 2
## # Groups:   Fecha [6]
##   Fecha      Totales
##   <date>       <dbl>
## 1 2025-02-24  14240.
## 2 2025-02-27  20630.
## 3 2025-03-06  66800.
## 4 2025-03-31  42850.
## 5 2025-04-08   4749.
## 6 2025-04-16    923.
nrow(Productos2025)
## [1] 32

Series

productoss_2025_ts <- ts(Productos2025$Totales,start =1, frequency =1)
productoss_2025_xts <- as.xts(productoss_2025_ts)

Gráfica de las serie

## Datos historicos de productos

ruta <- "C:\\Users\\Usuario\\Downloads\\ARCHIVOS DE POSIT\\Ventas_Suministros_Totales.xlsx"
excel_sheets(ruta)
## [1] "Ventas Totales Original"    "Servicios Totales Original"
# "Ventas Totales Original"    "Servicios Totales Original"
Productos_Totales <- as.data.frame(read_xlsx(ruta, 
                                             sheet = "Ventas Totales Original"))
Productos_Totales$Semana <- format(Productos_Totales$Fecha, format = "%Y-%U")
Productos_Totales$mes <- format(Productos_Totales$Fecha, format = "%Y-%m")
head(Productos_Totales)
##   Folio               Fecha           RFC                       Empresa
## 1     1 2019-07-01 10:01:03 VEPS740807T84 Silvia Elena Velasco Palacios
## 2     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 3     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 4     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 5     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
## 6     2 2019-07-01 11:40:32 CERI890615EU1         ISRAEL CETINA ROSALES
##   Cantidad            Unidad
## 1        1 Bidón de plástico
## 2        1             Pieza
## 3        1             Pieza
## 4        1             Pieza
## 5        1             Pieza
## 6        1             Pieza
##                                                  Descripcion ValorUnitario
## 1 Algicin marca Spin en presentación de garrafa de 20 Litros        700.00
## 2                Kit de Sello y espaciadores Piston Superior        308.04
## 3                Kit de sello y espaciadores Piston Inferior        811.78
## 4                              Kit Piston Superior 9000/9100        968.58
## 5                              Kit Piston Inferior 9000/9100       1784.38
## 6                               Engrane motriz Inferior 9100       1092.00
##       Total  Semana     mes
## 1  812.0000 2019-26 2019-07
## 2  357.3264 2019-26 2019-07
## 3  941.6648 2019-26 2019-07
## 4 1123.5528 2019-26 2019-07
## 5 2069.8808 2019-26 2019-07
## 6 1266.7200 2019-26 2019-07
nrow(Productos_Totales)
## [1] 1995
productos <- data.frame(Fecha = Productos_Totales$Fecha, Totales = Productos_Totales$Total)

Suma de historicos

productos <- productos %>% 
  group_by(Fecha = as.Date(Fecha)) %>% 
  summarize(Totales = sum(Totales), 
            .groups = "keep")
head(productos)
## # A tibble: 6 × 2
## # Groups:   Fecha [6]
##   Fecha      Totales
##   <date>       <dbl>
## 1 2019-07-01  25826.
## 2 2019-07-03   3138.
## 3 2019-07-04   5330.
## 4 2019-07-05  10146.
## 5 2019-07-06  10962 
## 6 2019-07-08  16194.
nrow(productos)
## [1] 695
nrow(productos)
## [1] 695

Serie

productos_ts <- ts(productos$Totales, start = 1, frequency = 1)

Gráfica por dia

Union de los datos

PRODTOTAL <- merge(x = productos, y = Productos2025, all = T)
head(PRODTOTAL)
##        Fecha   Totales
## 1 2019-07-01 25826.333
## 2 2019-07-03  3137.800
## 3 2019-07-04  5329.713
## 4 2019-07-05 10145.534
## 5 2019-07-06 10962.000
## 6 2019-07-08 16193.600
tail(PRODTOTAL)
##          Fecha  Totales
## 722 2025-02-24 14240.16
## 723 2025-02-27 20630.00
## 724 2025-03-06 66799.76
## 725 2025-03-31 42850.40
## 726 2025-04-08  4749.04
## 727 2025-04-16   923.36
nrow(PRODTOTAL)
## [1] 727

Serie semanal

prodsem_ts <- ts(PRODTOTAL$Totales, start = c(2019,07,01), 
                 end = c(2025,04,16),frequency = 52)

Gráfica

Transformación

PRODTOTAL$Semana <- format(PRODTOTAL$Fecha, format = "%Y-%U")

lambda <- boxcox(x = as.numeric(prodsem_ts), objective.name = "Log-Likelihood", optimize = T)
lambda$lambda
## [1] 0.03181016
# [1] 0.03181016
PS <- boxcoxTransform(x = as.numeric(prodsem_ts), lambda = lambda$lambda )
head(PS)
## [1] 11.992777  9.176249  9.866464 10.720959 10.824884 11.352690
tail(PS)
## [1] 12.368630  9.370100 10.515330 11.702842 12.658879  9.612385

Serie semanal con boxcox

Grafica semanal

ts_plot(serie_semana_prod, color = "blue", Xtitle = "Semanas", Ytitle = "Valores", title = " Serie semanal de productos")

Diferenciar

ndiffs(serie_semana_prod)
## [1] 0

Modelo

LSTAR_PS <- lstar(x = serie_semana_prod, m = 11)
## Using maximum autoregressive order for low regime: mL = 11 
## Using maximum autoregressive order for high regime: mH = 11 
## Using default threshold variable: thDelay=0
## Performing grid search for starting values...
## Starting values fixed: gamma =  100 , th =  10.69711 ; SSE =  836.4362 
## Grid search selected lower/upper bound gamma (was:  1 100 ]). 
##                    Might try to widen bound with arg: 'starting.control=list(gammaInt=c(1,200))'
## Optimization algorithm converged
## Optimized values fixed for regime 2  : gamma =  100.0011 , th =  10.69386 ; SSE =  836.4204
summary(LSTAR_PS)
## 
## Non linear autoregressive model
## 
## LSTAR model
## Coefficients:
## Low regime:
##      const.L       phiL.1       phiL.2       phiL.3       phiL.4       phiL.5 
##  2.974868838  0.063487520 -0.041369311  0.068235856  0.079083602  0.171904910 
##       phiL.6       phiL.7       phiL.8       phiL.9      phiL.10      phiL.11 
##  0.033047705 -0.010511002 -0.008069573  0.113793333  0.192160578  0.067601517 
## 
## High regime:
##     const.H      phiH.1      phiH.2      phiH.3      phiH.4      phiH.5 
## 13.31016401 -0.17027080  0.04944138 -0.07778873 -0.14415242 -0.24875581 
##      phiH.6      phiH.7      phiH.8      phiH.9     phiH.10     phiH.11 
## -0.21228488  0.05456323  0.06367833 -0.29062782 -0.37851561  0.05065561 
## 
## Smoothing parameter: gamma = 100 
## 
## Threshold
## Variable: Z(t) = + (1) X(t) + (0) X(t-1)+ (0) X(t-2)+ (0) X(t-3)+ (0) X(t-4)+ (0) X(t-5)+ (0) X(t-6)+ (0) X(t-7)+ (0) X(t-8)+ (0) X(t-9)+ (0) X(t-10)
## 
## Value: 10.69 
## 
## Residuals:
##       Min        1Q    Median        3Q       Max 
## -4.535384 -1.277977  0.062404  1.089145  5.880050 
## 
## Fit:
## residuals variance = 2.698,  AIC = 360, MAPE = 13.95%
## 
## Coefficient(s):
##            Estimate  Std. Error  t value  Pr(>|z|)    
## const.L   2.9748688   2.1481983   1.3848 0.1661074    
## phiL.1    0.0634875   0.1093727   0.5805 0.5615981    
## phiL.2   -0.0413693   0.0733752  -0.5638 0.5728866    
## phiL.3    0.0682359   0.0713535   0.9563 0.3389170    
## phiL.4    0.0790836   0.0696404   1.1356 0.2561244    
## phiL.5    0.1719049   0.0732089   2.3481 0.0188673 *  
## phiL.6    0.0330477   0.0749415   0.4410 0.6592275    
## phiL.7   -0.0105110   0.0714107  -0.1472 0.8829814    
## phiL.8   -0.0080696   0.0739573  -0.1091 0.9131143    
## phiL.9    0.1137933   0.0731767   1.5550 0.1199344    
## phiL.10   0.1921606   0.0717323   2.6789 0.0073874 ** 
## phiL.11   0.0676015   0.0692452   0.9763 0.3289341    
## const.H  13.3101640   4.0967207   3.2490 0.0011582 ** 
## phiH.1   -0.1702708   0.1925419  -0.8843 0.3765175    
## phiH.2    0.0494414   0.1114013   0.4438 0.6571775    
## phiH.3   -0.0777887   0.1140504  -0.6821 0.4952037    
## phiH.4   -0.1441524   0.1146889  -1.2569 0.2087900    
## phiH.5   -0.2487558   0.1116973  -2.2271 0.0259437 *  
## phiH.6   -0.2122849   0.1130991  -1.8770 0.0605206 .  
## phiH.7    0.0545632   0.1130474   0.4827 0.6293387    
## phiH.8    0.0636783   0.1120675   0.5682 0.5698896    
## phiH.9   -0.2906278   0.1140251  -2.5488 0.0108093 *  
## phiH.10  -0.3785156   0.1128403  -3.3544 0.0007953 ***
## phiH.11   0.0506556   0.1154381   0.4388 0.6607977    
## gamma   100.0010998 182.3116034   0.5485 0.5833366    
## th       10.6938621   0.0459660 232.6474 < 2.2e-16 ***
## ---
## Signif. codes:  0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
## 
## Non-linearity test of full-order LSTAR model against full-order AR model
##  F = 1.1492 ; p-value = 0.32301 
## 
## Threshold 
## Variable: Z(t) = + (1) X(t) + (0) X(t-1)+ (0) X(t-2)+ (0) X(t-3)+ (0) X(t-4)+ (0) X(t-5)+ (0) X(t-6)+ (0) X(t-7)+ (0) X(t-8)+ (0) X(t-9)+ (0) X(t-10)

Residuales

checkresiduals(LSTAR_PS, col = "darkgreen")

## 
##  Ljung-Box test
## 
## data:  Residuals
## Q* = 0.60409, df = 10, p-value = 1
## 
## Model df: 0.   Total lags used: 10

Criterio AIC

AIC(LSTAR_PS)
## [1] 359.6933

Pronóstico

fsem <- predict(LSTAR_PS, n.ahead = length(serie_semana_prod[297:310]))
fsem <- data.frame(pronosticos = fsem)
head(fsem)
##   pronosticos
## 1   10.453485
## 2   10.710614
## 3   10.006611
## 4   11.421939
## 5    9.917958
## 6   10.382316
tail(fsem)
##    pronosticos
## 9     11.04110
## 10    10.48856
## 11    10.47347
## 12    10.61219
## 13    10.55269
## 14    10.76535
nrow(fsem)
## [1] 14

Exactitud

accuracy(fsem$pronosticos, serie_semana_prod[297:310])
##                 ME     RMSE     MAE      MPE     MAPE
## Test set 0.3555935 1.408671 1.14663 1.794215 10.46652

Intervalo de confianza

errores_prod_semana <- residuals(LSTAR_PS)
sd_errores_prod_semana <- sd(errores_prod_semana, na.rm =T)
margen_error_prod_semana <- sd_errores_prod_semana * qnorm(0.975)

Limites

fsem$inf <- fsem$pronosticos - margen_error_prod_semana
fsem$sup <- fsem$pronosticos + margen_error_prod_semana
head(fsem)
##   pronosticos      inf      sup
## 1   10.453485 7.169870 13.73710
## 2   10.710614 7.426999 13.99423
## 3   10.006611 6.722996 13.29023
## 4   11.421939 8.138324 14.70555
## 5    9.917958 6.634343 13.20157
## 6   10.382316 7.098701 13.66593
tail(fsem)
##    pronosticos      inf      sup
## 9     11.04110 7.757480 14.32471
## 10    10.48856 7.204943 13.77217
## 11    10.47347 7.189856 13.75709
## 12    10.61219 7.328576 13.89581
## 13    10.55269 7.269080 13.83631
## 14    10.76535 7.481738 14.04897
nrow(fsem)
## [1] 14
fsem
##    pronosticos      inf      sup
## 1    10.453485 7.169870 13.73710
## 2    10.710614 7.426999 13.99423
## 3    10.006611 6.722996 13.29023
## 4    11.421939 8.138324 14.70555
## 5     9.917958 6.634343 13.20157
## 6    10.382316 7.098701 13.66593
## 7    10.763715 7.480100 14.04733
## 8     9.513339 6.229724 12.79695
## 9    11.041095 7.757480 14.32471
## 10   10.488558 7.204943 13.77217
## 11   10.473471 7.189856 13.75709
## 12   10.612191 7.328576 13.89581
## 13   10.552695 7.269080 13.83631
## 14   10.765353 7.481738 14.04897

Gráficas de los pronósticos

## Comprobación

datos <- data.frame(prediccion = as.numeric(fsem$pronosticos), valores_reales = serie_semana_prod[297:310], limite_sup = as.numeric(fsem$sup), limite_inf = as.numeric(fsem$inf))
datos
##    prediccion valores_reales limite_sup limite_inf
## 1   10.453485      12.634296   13.73710   7.169870
## 2   10.710614       8.436725   13.99423   7.426999
## 3   10.006611       9.894040   13.29023   6.722996
## 4   11.421939      12.396898   14.70555   8.138324
## 5    9.917958      10.186424   13.20157   6.634343
## 6   10.382316      10.150551   13.66593   7.098701
## 7   10.763715      10.116112   14.04733   7.480100
## 8    9.513339      12.038439   12.79695   6.229724
## 9   11.041095      12.368630   14.32471   7.757480
## 10  10.488558       9.370100   13.77217   7.204943
## 11  10.473471      10.515330   13.75709   7.189856
## 12  10.612191      11.702842   13.89581   7.328576
## 13  10.552695      12.658879   13.83631   7.269080
## 14  10.765353       9.612385   14.04897   7.481738

Inverso de Boxcox

valores_reales <- InvBoxCox(x = datos, lambda = 0.03181016)
valores_reales
##    prediccion valores_reales limite_sup limite_inf
## 1    8305.728      40950.559   89062.16   638.1383
## 2   10067.565       1760.880  106459.46   786.2199
## 3    5928.584       5442.721   65157.32   442.5489
## 4   17038.089      34555.524  173497.49  1390.5041
## 5    5542.612       6792.961   61217.44   411.3447
## 6    7873.405       6611.305   84755.31   602.1759
## 7   10474.051       6441.342  110441.62   820.7023
## 8    4068.895      26693.762   45978.73   293.9868
## 9   12869.433      33861.797  133702.59  1026.0078
## 10   8527.148       3644.488   91261.81   656.6173
## 11   8431.208       8699.998   90309.22   648.6056
## 12   9354.165      20922.389   99443.04   725.9793
## 13   8946.922      41674.770   95421.05   691.7579
## 14  10486.838       4389.939  110566.71   821.7889

##n Gráfica de los valores